home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / make_ufun.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  3KB  |  72 lines
  1. ;;; MAKE_UFUN  Makes Ufun list for user-defined functions.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7.  
  8. (in-package 'compiler)
  9.  
  10. (defvar gazonk (make-package 'symbol-table :use nil))
  11. (defvar eof (cons nil nil))
  12. (defvar *Ufun-out*)
  13.  
  14. (defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0))
  15.  
  16. (defun make-Ufun (in-files &key (out-file "Ufun_list.lsp"))
  17.   (with-open-file (*Ufun-out* out-file :direction :output)
  18.     (print '(in-package "COMPILER") *Ufun-out*)
  19.     (dolist (file in-files)
  20.       (with-open-file (in (merge-pathnames file #".lsp"))
  21.         (loop (when (eq (setq form (read in nil eof)) eof) (return))
  22.               (do-form form))))))
  23.  
  24. (defun do-form (form)
  25.     (when (consp form)
  26.         (case (car form)
  27.           (defun
  28.            (let ((*package* (find-package 'compiler)))
  29.                 (print `(si:putprop
  30.                          ',(cadr form)
  31.                          ,(get-cname (cadr form))
  32.                          'Ufun)
  33.                        *Ufun-out*))
  34.            (eval form))
  35.           (progn (mapc #'do-form (cdr form)))
  36.           (eval-when
  37.            (if (member 'load (cadr form))
  38.                (mapc #'do-form (cddr form))
  39.                (if (member 'compile (cadr form))
  40.                    (mapc #'eval (cddr form)))))
  41.           (t
  42.            (if (macro-function (car form))
  43.                (do-form (macroexpand-1 form))
  44.                (eval form))))))
  45.  
  46. (defun get-cname (symbol &aux (name (symbol-name symbol)))
  47.   (setf (fill-pointer *str*) 0)
  48.   (vector-push #\U *str*)
  49.   (dotimes (n (length name))
  50.            (let ((char (schar name n)))
  51.                 (cond ((alphanumericp char)
  52.                        (vector-push (char-downcase char) *str*))
  53.                       ((char= char #\-) (vector-push #\_ *str*))
  54.                       ((char= char #\*) (vector-push #\A *str*))
  55.                       )))
  56.   (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table)
  57.     (unless flag
  58.             ;(setq foo (intern (copy-seq *str*) 'symbol-table))
  59.             (setq foo (intern *str* 'symbol-table))
  60.             ;(set foo nil)
  61.             (return-from get-cname *str*))
  62.     (gensym *str*)
  63.     (gensym 0)
  64.     (loop
  65.      (setq name (symbol-name (gensym)))
  66.      (multiple-value-bind (foo flag1)
  67.                           (intern name 'symbol-table)
  68.                           (unless flag1
  69.                                   ;(set foo nil)
  70.                                   (return-from get-cname name)))))
  71.   )
  72.